open Ast FormatTemplate

fun marktypepat (p as MarkTyPat _, _, _) = p
  | marktypepat (p, left, right) = MarkTyPat (p, (left, right))

fun marktemplate (t as MarkTemplate _, _, _) = t
  | marktemplate (t, left, right) = MarkTemplate (t, (left, right))

fun markinstance (i as MarkInstance _, _, _) = i
  | markinstance (i, left, right) = MarkInstance (i, (left, right))

%%

%term
    EOF
  | SPECIAL of char
  | CONTEXT_HEADER of unit
  | CONTEXT_INNER of unit
  | CONTEXT_DEFINING of unit
  | CONTEXT_DEFINING_WITH_INNER of unit
  | COMMA
  | COLON
  | ID of string
  | PREFIXEDLABEL of string
  | LPAREN
  | RPAREN
  | LBRACE
  | RBRACE
  | LBRACKET
  | RBRACKET
  | STRING of string
  | DOTDOTDOT
  | WILD
  | ASTERISK
  | INT of string
  | DOT
  | EQUALOP
  | FORMATCOMMENTSTART | FORMATCOMMENTEND
  | DITTOTAG
  | PREFIXTAG
  | FORMATTERTAG
  | FORMATPARAMSTAG
  | DESTINATIONTAG
  | HEADERTAG
  | FORMATEXTERNTAG
  | FORMATTAG
  | LOCALFORMATTAG of string
  | NEWLINE
  | STARTOFINDENT of int
  | FORMATINDICATOR of
    {
      space : bool,
      newline : {priority : FormatTemplate.priority} option
    }
  | ASSOCINDICATOR of
    {cut : bool, strength : int, direction : FormatTemplate.assocDirection}

%nonterm
    start of parse_result
  | ident of string
  | id of string
  | int of int
  | op_op of unit
  | qid of string
  | selector of string
  | header_format_comment_list of headerFormatComment list
  | header_format_specs of headerFormatComment
  | inner_header_format_comment_list of innerHeaderFormatComment list
  | inner_header_format_specs of innerHeaderFormatComment
  | inner_header_format_spec of innerHeaderFormatComment
  | ditto_spec of string
  | prefix_spec of string
  | prefix_spec_opt of string
  | formatter_spec of string * string
  | formatparams_spec of string list
  | formatextern_spec of string * string
  | formatparam_list of string list
  | destination_spec of string
  | funheader_spec of string
  | defining_format_comment of definingFormatComment
  | defining_format_comment_list of definingFormatComment list
  | defining_format_comment_list_with_inners of
    innerHeaderFormatComment list * definingFormatComment list
  | formattag of formattag
  | localformattags of formattag list
  | localformattag of formattag
  | typepat of typepat
  | typepat' of typepat
  | tuple_typepat of typepat list
  | typepat_rows of (string * typepat) list * bool
  | typepat_field of string * typepat
  | atypepat of typepat
  | atypepat_list of typepat list
  | templates of template list
  | template of template
  | inst of instance
  | opt_typed of string option
  | insts of instance list
  | templates_comma_list of template list list

%verbose
%pos int
%start start
%eop EOF
%noshift EOF
%name FormatComment
%header (structure FormatCommentLrVals)
%footer ()

%keyword
    DITTOTAG
    PREFIXTAG
    FORMATTERTAG
    FORMATPARAMSTAG
    DESTINATIONTAG
    HEADERTAG
    FORMATEXTERNTAG
    FORMATTAG

%%

id
    : ID
      (ID)
    | ASTERISK
      ("*")

ident
    : ID
      (ID)
    | ASTERISK
      ("*")
    | EQUALOP
      ("=")

qid
    : ID DOT qid
      (ID ^ "." ^ qid)
    | ident
      (ident)

selector
    : id
      (id)
    | INT
      (INT)
    | PREFIXEDLABEL
      (PREFIXEDLABEL)

start
    : CONTEXT_HEADER header_format_comment_list
      (Header header_format_comment_list)
    | CONTEXT_INNER inner_header_format_comment_list
      (InnerHeader inner_header_format_comment_list)
    | CONTEXT_DEFINING defining_format_comment_list
      (Defining defining_format_comment_list)
    | CONTEXT_DEFINING_WITH_INNER defining_format_comment_list_with_inners
      (DefiningWithInner defining_format_comment_list_with_inners)

header_format_comment_list
    : (* none *)
      ([])
    | FORMATCOMMENTSTART header_format_specs FORMATCOMMENTEND
      header_format_comment_list
      (header_format_specs :: header_format_comment_list)

header_format_specs
    : (* none *)
      ({
         destinationOpt = NONE,
         funHeaderOpt = NONE,
         formatters = [],
         params = {params = [], externs = []},
         ditto = [],
         prefix = Ast.DefaultFormatterPrefix
       })
    | ditto_spec header_format_specs
      ({
         destinationOpt = #destinationOpt header_format_specs,
         funHeaderOpt = #funHeaderOpt header_format_specs,
         formatters = #formatters header_format_specs,
         params = #params header_format_specs,
         ditto = [ditto_spec],
         prefix = #prefix header_format_specs
       })
    | prefix_spec header_format_specs
      ({
         destinationOpt = #destinationOpt header_format_specs,
         funHeaderOpt = #funHeaderOpt header_format_specs,
         formatters = #formatters header_format_specs,
         params = #params header_format_specs,
         ditto = #ditto header_format_specs,
         prefix = prefix_spec
       })
    | formatter_spec header_format_specs
      ({
         destinationOpt = #destinationOpt header_format_specs,
         funHeaderOpt = #funHeaderOpt header_format_specs,
         formatters = formatter_spec :: (#formatters header_format_specs),
         params = #params header_format_specs,
         ditto = #ditto header_format_specs,
         prefix = #prefix header_format_specs
       })
    | formatparams_spec header_format_specs
      ({
         destinationOpt = #destinationOpt header_format_specs,
         funHeaderOpt = #funHeaderOpt header_format_specs,
         formatters = #formatters header_format_specs,
         params = {
           params = formatparams_spec @ #params (#params header_format_specs),
           externs = #externs (#params header_format_specs)
         },
         ditto = #ditto header_format_specs,
         prefix = #prefix header_format_specs
       })
    | formatextern_spec header_format_specs
      ({
         destinationOpt = #destinationOpt header_format_specs,
         funHeaderOpt = #funHeaderOpt header_format_specs,
         formatters = #formatters header_format_specs,
         params = {
           params = #params (#params header_format_specs),
           externs = formatextern_spec :: #externs (#params header_format_specs)
         },
         ditto = #ditto header_format_specs,
         prefix = #prefix header_format_specs
       })
    | destination_spec header_format_specs
      ({
         destinationOpt = SOME destination_spec,
         funHeaderOpt = #funHeaderOpt header_format_specs,
         formatters = #formatters header_format_specs,
         params = #params header_format_specs,
         ditto = #ditto header_format_specs,
         prefix = #prefix header_format_specs
       })
    | funheader_spec header_format_specs
      ({
         destinationOpt = #destinationOpt header_format_specs,
         funHeaderOpt = SOME funheader_spec,
         formatters = #formatters header_format_specs,
         params = #params header_format_specs,
         ditto = #ditto header_format_specs,
         prefix = #prefix header_format_specs
       })

inner_header_format_comment_list
    : (* none *)
      ([])
    | FORMATCOMMENTSTART inner_header_format_specs FORMATCOMMENTEND
      inner_header_format_comment_list
      (inner_header_format_specs :: inner_header_format_comment_list)
    | FORMATCOMMENTSTART FORMATCOMMENTEND
      inner_header_format_comment_list
      (inner_header_format_comment_list)

inner_header_format_specs
    : inner_header_format_spec
      (inner_header_format_spec)
    | inner_header_format_spec inner_header_format_specs
      ({
         formatters = #formatters inner_header_format_spec
                      @ #formatters inner_header_format_specs,
         params = #params inner_header_format_spec
                  @ #params inner_header_format_specs,
         prefix = case #prefix inner_header_format_spec of
                    SOME x => SOME x
                  | NONE => #prefix inner_header_format_specs
       })

inner_header_format_spec
    : formatparams_spec
      ({
         formatters = nil,
         params = formatparams_spec,
         prefix = NONE
       })
(* FIXME: These tags will be enabled.
    | prefix_spec
      ({
         formatters = nil,
         params = nil,
         prefix = SOME prefix_spec
       })
    | formatter_spec
      ({
         formatters = [formatter_spec],
         params = nil,
         prefix = NONE
       })
*)

prefix_spec
    : PREFIXTAG ID
      (ID)

ditto_spec
    : DITTOTAG ID
      (ID)

prefix_spec_opt
    : (* none *)
      (Ast.DefaultFormatterPrefix)
    | prefix_spec
      (prefix_spec)

formatter_spec
    : FORMATTERTAG LPAREN qid RPAREN qid
      (qid1, qid2)

formatparams_spec
    : FORMATPARAMSTAG LPAREN formatparam_list RPAREN
      (formatparam_list)

formatextern_spec
    : FORMATEXTERNTAG LPAREN ID RPAREN qid
      (ID, qid)

formatparam_list
    : ID
      ([ID])
    | ID COMMA formatparam_list
      (ID :: formatparam_list)

destination_spec
    : DESTINATIONTAG STRING
      (STRING)

funheader_spec
    : HEADERTAG STRING
      (STRING)

defining_format_comment
    : FORMATCOMMENTSTART prefix_spec_opt formattag localformattags
      FORMATCOMMENTEND
      ({
         prefix = prefix_spec_opt,
         primaryTag = formattag,
         localTags = localformattags
       })

defining_format_comment_list
    : (* none *)
      ([])
    | defining_format_comment_list defining_format_comment
      (defining_format_comment_list @ [defining_format_comment])
    | defining_format_comment_list
      FORMATCOMMENTSTART FORMATCOMMENTEND
      (defining_format_comment_list)
    | defining_format_comment_list
      FORMATCOMMENTSTART prefix_spec_opt DITTOTAG FORMATCOMMENTEND
      (let
         val {primaryTag, localTags, ...} =
             List.last defining_format_comment_list
      in
        defining_format_comment_list @
        [{
           prefix = prefix_spec_opt,
           primaryTag = primaryTag,
           localTags = localTags
         }]
      end
      handle Empty => defining_format_comment_list)

defining_format_comment_list_with_inners
    : (* none *)
      ((nil, nil))
    | FORMATCOMMENTSTART inner_header_format_specs FORMATCOMMENTEND
      defining_format_comment_list_with_inners
      (
        (inner_header_format_specs
         :: #1 defining_format_comment_list_with_inners,
         #2 defining_format_comment_list_with_inners)
      )
    | defining_format_comment defining_format_comment_list_with_inners
      (
        (#1 defining_format_comment_list_with_inners,
         defining_format_comment
         :: #2 defining_format_comment_list_with_inners)
      )
    | FORMATCOMMENTSTART FORMATCOMMENTEND
      defining_format_comment_list_with_inners
      (defining_format_comment_list_with_inners)

formattag
    : FORMATTAG LPAREN typepat RPAREN templates
      ({id = NONE, typepat = typepat, templates = templates})
    | FORMATTAG templates (* typepat is dummy *)
      ({id = NONE, typepat = VarTyPat "_", templates = templates})

localformattags
    : (* none *)
      ([])
    | localformattag localformattags
      (localformattag :: localformattags)

localformattag
    : LOCALFORMATTAG LPAREN typepat RPAREN templates
      ({
         id = SOME (LOCALFORMATTAG, nil),
         typepat = typepat,
         templates = templates
       })
    | LOCALFORMATTAG LPAREN typepat RPAREN formatparams_spec templates
      ({
         id = SOME (LOCALFORMATTAG, formatparams_spec),
         typepat = typepat,
         templates = templates
       })

typepat
    : tuple_typepat
      (marktypepat
         (TupleTyPat tuple_typepat, tuple_typepatleft, tuple_typepatright))
    | typepat'
      (typepat')

tuple_typepat
    : typepat' ASTERISK tuple_typepat
      (typepat' :: tuple_typepat)
    | typepat' ASTERISK typepat'
      ([typepat'1, typepat'2])

typepat'
    : LBRACE typepat_rows RBRACE
      (marktypepat (RecordTyPat typepat_rows, LBRACEleft, RBRACEright))
    | LBRACE RBRACE
      (marktypepat (RecordTyPat ([], false), LBRACEleft, RBRACEright))
    | LPAREN typepat RPAREN
      (marktypepat (typepat, LPARENleft, RPARENright))
    | atypepat
      (marktypepat (atypepat, atypepatleft, atypepatright))

atypepat
    : LPAREN atypepat_list RPAREN ID
      (TyConTyPat (ID, atypepat_list))
    | LPAREN atypepat_list RPAREN ID COLON ID
      (TypedTyConTyPat (ID1, atypepat_list, ID2))
    | atypepat ID
      (TyConTyPat (ID, [atypepat]))
    | atypepat ID COLON ID
      (TypedTyConTyPat (ID1, [atypepat], ID2))
    | ID
      (VarTyPat ID)
    | ID COLON ID
      (TypedVarTyPat (ID1, ID2))
    | WILD
      (WildTyPat)

atypepat_list
    : atypepat COMMA atypepat_list
      (atypepat :: atypepat_list)
    | atypepat COMMA atypepat
      ([atypepat1, atypepat2])

typepat_rows
    : typepat_field COMMA typepat_rows
      (typepat_field :: (#1 typepat_rows), #2 typepat_rows)
    | typepat_field
      ([typepat_field], false)
    | DOTDOTDOT
      ([], true)

typepat_field
    : selector
      (selector, (VarTyPat selector))
    | selector COLON typepat
      (selector, typepat)

templates
    : template templates
      (template :: templates)
    | STARTOFINDENT templates RBRACKET templates
      (marktemplate
         (
           StartOfIndent STARTOFINDENT,
           STARTOFINDENTleft,
           STARTOFINDENTright
         ) ::
       templates1 @
       [marktemplate (EndOfIndent, RBRACKETleft, RBRACKETright)] @
       templates2)
    | (* none *)
      ([])

template
    : STRING
      (marktemplate (Term STRING, STRINGleft, STRINGright))
    | NEWLINE
      (marktemplate (Newline, NEWLINEleft, NEWLINEright))
    | ASSOCINDICATOR LBRACE templates RBRACE
      (marktemplate
         (
           Guard (SOME ASSOCINDICATOR, templates),
           ASSOCINDICATORleft,
           RBRACEright
         ))
    | LBRACE templates RBRACE
      (marktemplate (Guard (NONE, templates), LBRACEleft, RBRACEright))
    | FORMATINDICATOR
      (marktemplate
         (
           Indicator FORMATINDICATOR,
           FORMATINDICATORleft,
           FORMATINDICATORright
         ))
    | inst
      (marktemplate (Instance inst, instleft, instright))

inst
    : ID opt_typed
      (markinstance (Atom (ID, opt_typed), IDleft, opt_typedright))
    | ID opt_typed LPAREN insts RPAREN LPAREN templates_comma_list RPAREN
      (markinstance
         (App (ID, opt_typed, insts, templates_comma_list),IDleft, RPARENright))
    | ID opt_typed LPAREN RPAREN LPAREN templates_comma_list RPAREN
      (markinstance
         (App (ID, opt_typed, [], templates_comma_list), IDleft, RPARENright))
    | ID opt_typed LPAREN insts RPAREN
      (markinstance (App (ID, opt_typed, insts, []), IDleft, RPARENright))
    | ID opt_typed LPAREN RPAREN
      (markinstance (App (ID, opt_typed, [], []), IDleft, RPARENright))

opt_typed
    : (* none *)
      (NONE)
    | COLON ID
      (SOME ID)

insts
    : inst COMMA insts
      (inst :: insts)
    | inst
      ([inst])

templates_comma_list
    : templates COMMA templates_comma_list
      (templates :: templates_comma_list)
    | templates
      ([templates])
